(FILECREATED " 1-NOV-73 19:49:45" S-TOTAL)
(LISPXPRINT (QUOTE TOTALVARS)
T)
[RPAQQ TOTALVARS
((* Lisp system type functions)
(FNS DWIMUSERFN LISTFILE LISTFILES GSETQ GSET Y/N PUTPROP
LMLISPFOR FORGETTOKEN FOREXPRESSIONS FORNEXT FORVARNAME
FORMAKECOND FORMAKESETQ FORINITIAL FORPROGVAR FORGONEXT
FORPACKWORDS FORTESTANDSET FORNEGATION EDITM)
(USERMACROS ?= !← EF PPT MAC EVAL -)
[ADDVARS (PRETTYTYPELST (CHANGEDITMACROS USERMACROS
"edit macros")
(NEWVARSLST VARS "variables")
(CHANGEDPROPLST PROP "properties")
(CHANGEDADVICELST ADVICE "advice"))
(PRETTYMACROS (* X (E (TERPRI)
(PRINT (QUOTE (* . X)))
(TERPRI]
(VARS DWIMUSERFN HOST (FORFIXFLG T)
(NEWVARSLST)
(CHANGEDITMACROS)
(CHANGEDPROPLST)
(CHANGEDADVICELST)
LMFORWORDS)
(PROP CLISPMACRO FOR)
(PROP CLISPWORD FOR)
[P (/PUT (QUOTE *)
(QUOTE PRETTYTYPE)
(QUOTE (LAMBDA NIL NIL]
(P (I.S.TYPE (QUOTE MAXIMUM)
(QUOTE (SETQ $$VAL (MAX $$VAL *)))
-999999
(QUOTE $$VAL))
(I.S.TYPE (QUOTE MINIMUM)
(QUOTE (SETQ $$VAL (MIN $$VAL *)))
999999
(QUOTE $$VAL]
(* Lisp system type functions)
(DEFINEQ
(DWIMUSERFN
[LAMBDA NIL
(* This function is called
(if the value of DWIMUSERFN is T) by DWIM if DWIM
doesn't think that a "FORM" is CLISP.
The definition given here says that, if
(FOO --) is in the code, and FOO doesn't have a
function definition, but does have a macro property,
to use the expansion of the macro.
The call to "CLISPTRAN" puts the translation in the
CLISP hash array, where other translations of CLISP
are kept)
(AND (NOT FAULTAPPLYFLG)
(LISTP FAULTX)
(LITATOM (CAR FAULTX))
(NOT (FGETD (CAR FAULTX)))
(PROG [(MACVAL (OR (GETP (CAR FAULTX)
(QUOTE CLISPMACRO))
(GETP (CAR FAULTX)
(QUOTE MACRO]
(* FAULTX is the form
which was in "ERROR".)
(AND MACVAL (NOT (EDITFINDP MACVAL (QUOTE ASSEMBLE)))
[CLISPTRAN FAULTX
(COND
((FMEMB (CAR MACVAL)
(QUOTE [LAMBDA NLAMBDA]))
(CONS MACVAL (CDR FAULTX)))
[(AND (CAR MACVAL)
(ATOM (CAR MACVAL)))
(EVALA (CADR MACVAL)
(LIST (CONS (CAR MACVAL)
(CDR FAULTX]
(T (SUBPAIR (CAR MACVAL)
(CDR FAULTX)
(CADR MACVAL]
(RETURN FAULTX])
(LISTFILE
[LAMBDA (LOCALFILE FOREIGNFILE LISTFILEHOST LISTFILELOGIN)
(* Calls FTP as a
SUBSYS)
(BKSYSBUF (CONCAT
"FTP
"
[SETQ LISTFILEHOST (OR LISTFILEHOST HOST
(SETQ HOST (PROGN (PRIN1
"HOST? ")
(READ T]
"
LOG "
[OR LISTFILELOGIN (GETP LISTFILEHOST (QUOTE LOGIN))
(AND (EQ LISTFILEHOST (QUOTE SAIL))
(SETQ LISTFILELOGIN (SELECTQ (MKATOM (USERNAME)
)
(MASINTER
"DEN,LMM")
(SRIDHARAN
"1,NSS")
(CARHART "1,RC")
NIL))
(EQ (APPLY* (QUOTE Y/N)
(QUOTE Y)
(CONCAT "SAIL login as "
LISTFILELOGIN "? "))
(QUOTE Y))
LISTFILELOGIN)
(PUT LISTFILEHOST (QUOTE LOGIN)
(PROGN (PRIN1 LISTFILEHOST T)
(PRIN1 " login? " T)
(READ T]
"
TE
SE " LOCALFILE "
" (OR FOREIGNFILE
(PROGN [SETQ FOREIGNFILE
(SUBSTRING LOCALFILE
([LAMBDA (TEM)
(OR (STRPOS "S-" LOCALFILE TEM NIL T T)
TEM]
(OR (STRPOS ">" LOCALFILE NIL NIL NIL T)
1))
(SUB1 (OR (STRPOS ";" LOCALFILE)
0]
(COND
((EQ (NTHCHAR FOREIGNFILE -1)
(QUOTE %.))
(GLC FOREIGNFILE)))
FOREIGNFILE))
"
DIS
QUI
QUI
"))
(KFORK (SUBSYS))
LOCALFILE])
(LISTFILES
[LAMBDA (FILLST) (* TO REDEFINE LISTFILES
TO FTP FILES ELSEWHERE)
[MAPC (OR FILLST NOTLISTEDFILES)
(FUNCTION (LAMBDA (FIL)
(LISTFILE (OR (INFILEP FIL)
(ERROR "no such file:" FIL)))
(/DSUBST NIL FIL NOTLISTEDFILES]
(SETQ NOTLISTEDFILES (/DREMOVE NIL NOTLISTEDFILES))
FILLST])
(GSETQ
[NLAMBDA (GSETVAR Y) (* Guaranteed to cause
VARS to be marked as
"CHANGED")
(GSET GSETVAR (EVAL Y])
(GSET
[LAMBDA (X Y) (* Guaranteed to cause
VARS to be marked as
"CHANGED")
(PROG1 (/SET X Y)
(/RPLACA (QUOTE NEWVARSLST)
(CONS X NEWVARSLST])
(Y/N
[NLAMBDA (DEFAULT MESS)
(* Prompts for one of DEFAULT, returning the char
typed, and completing the typein.
DEFAULT is an alist of (firstchar . restchars))
(PROG ((CNT (ITIMES DWIMWAIT 2))
R BUFS)
(COND
(MESS (AND (READP T)
(PRIN1 "π" T))
(PRIN1 MESS T)))
[COND
((NLISTP DEFAULT)
(SETQ DEFAULT (SELECTQ DEFAULT
[Y (QUOTE ((Y . es)
(N . o]
(QUOTE ((N . o)
(Y . es]
(AND MESS (READP T)
(DOBE))
(SETQ BUFS (CLBUFS))
LP (COND
((MINUSP (SETQ CNT (SUB1 CNT)))
(PRIN1 "...")
(PRIN1 (SETQ R (CAAR DEFAULT)))
(GO GOTIT))
((NOT (READP T))
(DISMISS 500)
(GO LP)))
RETRY
(SETQ R (RESETFORM (CONTROL T)
(READC T)))
GOTIT
(COND
((SETQ R (ASSOC R DEFAULT))
(PRIN1 (CDR R)
T)
(TERPRI T))
(T (PRIN1 "π")
(GO RETRY)))
(BKBUFS BUFS)
(RETURN (CAR R])
(PUTPROP
[LAMBDA (NAM PROP VAL)
(* This isn't really optimal, as the best
implementation would say WHICH PROP needed dumping)
(/RPLACA (QUOTE CHANGEDPROPLST)
(CONS NAM CHANGEDPROPLST))
(/PUT NAM PROP VAL])
(LMLISPFOR
[LAMBDA (L)
(PROG (N FV PV EPILOGUE PROLOGUE DOFORM DOTYPE VAR RANGE LST
VARNEXT NEXT NEXTS N2 N3 INIT TESTSET DOVAL N1 RETVAL
INITIALVAL)
(SETQ CLISPCHANGE T)
(SETQ N 1)
FORLOOP
(AND (PROG1 (COND
((EQ (CAR L)
(QUOTE NEW)) (* This COND is for
whether or not to
"PROGVAR" the variable)
(/RPLNODE L (CADR L)
(CDDR L)))
((EQ (CAR L)
(QUOTE OLD))
(SETQ L (CDR L))
NIL)
(T T))
[COND
((LISTP (CAR L))
(COND
((EQ (CAAR L)
(QUOTE SETQ))
(/RPLNODE
L
(CADAR L)
(CONS (QUOTE IS)
(CONS (CADDR (CAR L))
(CDR L]
(SETQ VAR (CAR L)))
(FORPROGVAR VAR))
(FORNEXT (SETQ VARNEXT (FORVARNAME "NEXT")))
(SETQ L (CDR L))
(SETQ N1 (SETQ N2 (SETQ N3 NIL)))
RANGELOOP
(AND
(SELECTQ
(CAR L)
(FROM (SETQ N1 (FORGETTOKEN))
(GO RANGELOOP))
(TO (SETQ N2 (FORGETTOKEN))
(GO RANGELOOP))
(BY (SETQ N3 (FORGETTOKEN))
(GO RANGELOOP))
(IN (FORTESTANDSET
(FORMAKECOND (FORNEGATION
(FORINITIAL (FORPROGVAR
(SETQ LST
(FORVARNAME "LIST")))
(FORGETTOKEN)))
(FORGONEXT)))
(FORTESTANDSET (FORMAKESETQ VAR (LIST (QUOTE CAR)
LST)))
(FORNEXT (FORMAKESETQ LST (LIST (QUOTE CDR)
LST)))
T)
(ON (FORTESTANDSET (FORMAKECOND (FORNEGATION VAR)
(FORGONEXT)))
(FORNEXT (FORMAKESETQ (FORINITIAL VAR (FORGETTOKEN))
(LIST (QUOTE CDR)
VAR)))
T)
(:=(/RPLNODE
L
(QUOTE FROM)
(NCONC
(LIST (CAADR L))
[AND (CADR (CADR L))
(OR [NOT (NUMBERP (CADR (CADR L]
(NOT (IGREATERP (CADR (CADR L))
999)))
(LIST (QUOTE TO)
(CADR (CADR L]
[AND (CADDR (CADR L))
(LIST (QUOTE BY)
(CADDR (CADR L]
(CDDR L)))
(GO RANGELOOP))
((← IS)
(/RPLACA L (QUOTE IS))
(FORTESTANDSET (FORMAKESETQ VAR (FORGETTOKEN)))
T)
(PROGN (OR N1 N2 N3 (ERROR "MISSING OPERATOR IN FOR"))
NIL))
(OR N1 N2 N3)
(ERROR "TOO MANY OPERATORS IN FOR"))
[COND
((OR N1 N2 N3)
(FORINITIAL VAR (OR N1 1))
(AND (LISTP N2)
(SETQ N2 (FORINITIAL (FORPROGVAR (FORVARNAME "MAX"))
N2)))
(SETQ N3 (COND
[N3 (COND
((ATOM N3)
N3)
(T (FORINITIAL (FORPROGVAR (FORVARNAME "INC"))
N3]
((AND (NUMBERP N1)
(NUMBERP N2)
(GREATERP N1 N2))
-1)
(T 1)))
[AND
N2
(FORTESTANDSET
(FORMAKECOND
(COND
[(NOT (NUMBERP N3))
(LIST (QUOTE COND)
(LIST (LIST (QUOTE MINUSP)
N3)
(LIST (QUOTE ILESSP)
VAR N2))
(LIST T (LIST (QUOTE OR)
(LIST (QUOTE ZEROP)
N3)
(LIST (QUOTE GREATERP)
VAR N2]
((MINUSP N3)
(LIST (QUOTE ILESSP)
VAR N2))
(T (LIST (QUOTE IGREATERP)
VAR N2)))
(FORGONEXT]
(FORNEXT (FORMAKESETQ VAR (LIST (QUOTE IPLUS)
VAR N3]
ASLOOP
(SELECTQ (CAR L)
(AS (SETQ L (CDR L))
(SETQ NEXTS (APPEND NEXTS NEXT))
(SETQ NEXT)
(GO FORLOOP))
[(IF WHEN)
(/RPLACA L (QUOTE WHEN))
(FORTESTANDSET (FORMAKECOND (FORNEGATION (
FORGETTOKEN))
(LIST (QUOTE GO)
VARNEXT]
[UNTIL (FORNEXT (FORMAKECOND (FORGETTOKEN)
(FORGONEXT]
[WHILE (FORTESTANDSET (FORMAKECOND (FORNEGATION
(FORGETTOKEN))
(FORGONEXT]
(GO FORTEST))
(GO ASLOOP)
FORTEST
(SETQ PROLOGUE (APPEND TESTSET (LIST (FORPACKWORDS "LOOP" N))
INIT PROLOGUE))
[SETQ EPILOGUE (CONS (FORPACKWORDS "NEXT" N)
(APPEND (REVERSE NEXT)
(REVERSE NEXTS)
(CONS (LIST (QUOTE GO)
(FORPACKWORDS "LOOP"
N))
EPILOGUE]
[SETQ TESTSET (SETQ INIT (SETQ NEXT (SETQ NEXTS]
(COND
((EQ (CAR L)
(QUOTE FOR))
(SETQ L (CDR L))
(SETQ N (ADD1 N))
(GO FORLOOP))) (* Here is where we test
for the "VALUE" of the
for)
(FORPROGVAR (QUOTE FOR-VALUE))
(* Go off the I.S.TYPE property which warren uses,
or the association list here, which is of the form
(settingform initialization returning
whattodowithafirst) -
I.S.TYPE is of same form except the
what-to-do-with-first part)
FVLP[SETQ FV
(OR [CDR (FASSOC (CAR L)
(QUOTE ((SUM (SETQ $$VAL (IPLUS $$VAL *))
0)
(IPLUS . SUM)
(ITIMES . PRODUCT)
(PRODUCT (SETQ $$VAL (ITIMES
$$VAL *))
1)
(AND . ALWAYS)
(ALWAYS (OR (SETQ $$VAL *)
(RETURN))
T)
(OR . ISSOME)
(ISSOME (AND (SETQ $$VAL *)
(RETURN $$VAL)))
(PROGN (SETQ $$VAL *))
(PROG2 . PROGN)
(DO *)
(NCONC . JOIN)
(LIST . COLLECT)
(COLLECT (SETQ $$VAL (TCONC $$VAL
*))
NIL
(CAR $$VAL)
(LCONC NIL *))
(THEREIS (AND *(RETURN I.V.))
NIL NIL
(AND *(RETURN T)))
(SUCHTHAT (AND *(RETURN I.V.))
NIL NIL
(AND *(RETURN T)))
(JOIN (SETQ $$VAL (LCONC $$VAL *))
NIL
(CAR $$VAL)
(LCONC NIL *))
(XLIST (SETQ $$VAL (CONS * $$VAL)))
(APPEND (SETQ $$VAL
(LCONC $$VAL
(APPEND *)))
NIL
(CAR $$VAL)
(LCONC NIL (APPEND *)))
(MAXIMUM (SETQ $$VAL (MAX $$VAL *))
-9999999 $$VAL)
(MAX . MAXIMUM)
(MINIMUM (SETQ $$VAL (MIN $$VAL *))
9999999 $$VAL)
(MIN . MINIMUM]
(GETP (CAR L)
(QUOTE I.S.TYPE))
(HELP (QUOTE (MAKE THIS A REGULAR FOR TYPE]
(COND
((NLISTP FV)
(/RPLACA L FV)
(GO FVLP)))
(SETQ L (CDR L))
FIRSTLP
(SELECTQ (CAR L)
[FIRST (SETQ INITIALVAL (SUBST (FORGETTOKEN)
(QUOTE *)
(OR (CADDDR FV)
(QUOTE *]
[FINALLY (SETQ RETVAL (LIST (FORGETTOKEN]
(GO FINISHUP))
(GO FIRSTLP)
FINISHUP
(SETQ DOFORM (SUBPAIR (QUOTE ($$VAL * I.V.))
(LIST (QUOTE FOR-VALUE)
(CAR (LAST (FOREXPRESSIONS)))
VAR)
(CAR FV)))
(FORINITIAL (QUOTE FOR-VALUE)
(OR INITIALVAL (CADR FV)))
[SETQ RETVAL
(SUBST (SUBST (QUOTE FOR-VALUE)
(QUOTE $$VAL)
(OR (CADDR FV)
(QUOTE $$VAL)))
(QUOTE $$VAL)
(COND
[RETVAL (COND
((EQ (CAAR RETVAL)
(QUOTE RETURN))
RETVAL)
(T (CONS (CAR RETVAL)
(QUOTE ((RETURN $$VAL]
(T (QUOTE ((RETURN $$VAL]
(* In a finally, the * means what would be returned
ordinarily; i.e. $val; so that finally
(RETURN <I *>) means to return i consed onto the
value; this hair is so that list finally <i *> will
work)
(RETURN (CONS (QUOTE PROG)
(CONS PV (NCONC INIT (DREVERSE PROLOGUE)
(LDIFF L (NLEFT L 1))
(LIST DOFORM)
EPILOGUE
(CONS (QUOTE RETURN)
RETVAL])
(FORGETTOKEN
[LAMBDA NIL
(PROG ((VARS (APPEND VARS PV)))
(DWIMIFY1B (CDR L)
L
(CDR L)
T T FAULTFN))
(PROG1 (CADR L)
(SETQ L (CDDR L])
(FOREXPRESSIONS
[LAMBDA NIL
(PROG ((VARS (APPEND VARS PV)))
(DWIMIFY1B L L L T NIL FAULTFN))
L])
(FORNEXT
[LAMBDA (ITEM)
(SETQ NEXT (CONS ITEM NEXT))
ITEM])
(FORVARNAME
[LAMBDA (STR)
(PACK (LIST STR " " VAR])
(FORMAKECOND
[LAMBDA (PRD DO)
(LIST (QUOTE COND)
(LIST PRD DO])
(FORMAKESETQ
[LAMBDA (VAR VAL)
(AND (NOT (EQ VAR VAL))
(LIST (QUOTE SETQ)
VAR VAL])
(FORINITIAL
[LAMBDA (VAR VAL)
(AND VAL (SETQ INIT (CONS (FORMAKESETQ VAR VAL)
INIT)))
VAR])
(FORPROGVAR
[LAMBDA (VAR)
(SETQ PV (CONS VAR PV))
VAR])
(FORGONEXT
[LAMBDA NIL
(LIST (QUOTE GO)
(COND
((EQ N 1)
(QUOTE RETURN))
(T (PACK (LIST "NEXT " (SUB1 N])
(FORPACKWORDS
[LAMBDA (STR VAL)
(PACK (LIST STR " " N])
(FORTESTANDSET
[LAMBDA (ITEM)
(SETQ TESTSET (CONS ITEM TESTSET))
ITEM])
(FORNEGATION
[LAMBDA (EXP)
(SELECTQ (CAR EXP)
((NOT NULL)
(CADR EXP))
(LIST (QUOTE NULL)
EXP])
(EDITM
[NLAMBDA X
(EDITL (LIST (OR (ASSOC (CAR X)
USERMACROS)
(ERROR (CAR X)
"not editable"))
USERMACROS)
(CDR X)
(CAR X)
(QUOTE edit))
(CAAR (/RPLACA (QUOTE CHANGEDITMACROS)
(CONS (CAR X)
CHANGEDITMACROS])
)
(ADDTOVAR USERMACROS (- NIL (ORR (NX)
(!NX)))
[EVAL NIL (E (EVAL (##]
[?= NIL (ORR [(E (MAP2C (ARGLIST (## 1))
(## 2 UP)
(FUNCTION (LAMBDA (X Y)
(PRIN1 X T)
(PRIN1 " = " T)
(PRINT Y T]
((E (QUOTE ?=?]
[EF NIL (ORR [(E (APPLY* (QUOTE EDITF)
(COND ((LISTP (## UP 1))
(## UP 1 1))
(T (## UP 1]
((E (QUOTE EF?]
(MAC (X . Y)
(E (/RPLACA (QUOTE CHANGEDITMACROS)
(CONS (COND ((LISTP (QUOTE X))
(CAR (QUOTE X)))
(T (QUOTE X)))
CHANGEDITMACROS))
T)
(M X . Y))
[PPT NIL (ORR ((E (RESETVAR PRETTYTRANFLG T (## PP))
T))
((E (QUOTE PPT?]
(!← NIL !0))
(ADDTOVAR EDITCOMSA !← PPT EF ?= EVAL -)
(ADDTOVAR EDITCOMSL MAC)
(ADDTOVAR PRETTYTYPELST (CHANGEDITMACROS USERMACROS "edit macros")
(NEWVARSLST VARS "variables")
(CHANGEDPROPLST PROP "properties")
(CHANGEDADVICELST ADVICE "advice"))
[ADDTOVAR PRETTYMACROS (* X (E (TERPRI)
(PRINT (QUOTE (* . X)))
(TERPRI]
(RPAQQ DWIMUSERFN T)
(RPAQQ HOST SAIL)
(RPAQ FORFIXFLG T)
(RPAQ NEWVARSLST)
(RPAQ CHANGEDITMACROS)
(RPAQ CHANGEDPROPLST)
(RPAQ CHANGEDADVICELST)
(RPAQQ LMFORWORDS
(FINALLY FIRST FOR WHILE UNTIL IF WHEN AS IS := ON IN BY TO
FROM NEW SUM IPLUS ITIMES PRODUCT AND ALWAYS OR
ISSOME PROGN PROG2 DO NCONC LIST COLLECT THEREIS
SUCHTHAT JOIN XLIST APPEND MAXIMUM MAX MINIMUM MIN))
(DEFLIST(QUOTE(
(FOR (FOREXP (LMLISPFOR FOREXP)))
))(QUOTE CLISPMACRO))
(DEFLIST(QUOTE(
(FOR (USERWORD . FOR))
))(QUOTE CLISPWORD))
(/PUT (QUOTE *)
(QUOTE PRETTYTYPE)
(QUOTE [LAMBDA NIL NIL]))
(I.S.TYPE (QUOTE MAXIMUM)
(QUOTE (SETQ $$VAL (MAX $$VAL *)))
-999999
(QUOTE $$VAL))
(I.S.TYPE (QUOTE MINIMUM)
(QUOTE (SETQ $$VAL (MIN $$VAL *)))
999999
(QUOTE $$VAL))
STOP